home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
yerk
/
mps231ss.hqx
/
Mops ƒ
/
Args
next >
Wrap
Text File
|
1993-02-20
|
6KB
|
231 lines
\ Support for named parms and local variables
24 constant MAXPL \ Should be enough!!
false value LOCFLG \ true = looking for local var tokens
create PARMLIST maxPL cells reserve
0 value SVHASH
false value FLOAT?
: FINDINPARMLIST \ ( addr -- loc# T OR -- F )
\ loc# counts from right to left in the local/parm list.
dup 1+ c@ & % = -> float?
hash -> svHash false
#PL 0exit
ParmList #PL 4* bounds DO
svHash i @ =
IF ( found )
drop #PL
i parmlist - 4/
- 1- true LEAVE
THEN
4 +LOOP ;
: ADDTOPARMLIST \ ( addr -- ) Adds an element to ParmList.
\ addr points to a counted string.
findinParmList ?error 95 \ Name not unique
#PL maxPL >= ?error 110
FltFlg 1 << float? if 1 or 1 ++> #F then -> FltFlg
svHash
#PL 1 ++> #PL 4* ParmList + ! ;
: FIRSTCHR
here 1+ c@ ;
: { immediate
local? if local? 0< ?error 92 -1 -> local? then
0 -> #PL 0 -> #P 0 -> #F 0 -> FltFlg false -> locFlg
BEGIN Mword drop \ Add parms or vars to parmlist
firstChr & - <> \ look for --
WHILE
firstChr dup & \ = swap & / = or
\ Note: we're now allowing / as an alternative to \
IF true -> locFlg
ELSE firstChr & } = ?error 111
locFlg nif 1 ++> #P then
here AddToParmList
THEN
REPEAT
local? NIF PLentry THEN \ In local sections, we do it at :LOC
& } parse 2drop \ eat characters until }
source nip 0< ?error 112 ; \ Err if no final }
\ FIND will call Pfind to attempt to find a name first.
\ If Pfind finds the name is a local, it returns true and the
\ cfa of LocParm, which is a dummy word whose handler compiles
\ a local reference.
: PFIND \ ( str-addr -- cfa T | -- str-addr F )
state
NIF false
ELSE dup FindInParmList
IF \ Found
-> loc# drop
float? IF ['] FlocParm ELSE ['] locParm THEN
true
ELSE false \ Not found
THEN
THEN ;
: ,EXEC \ ( cfa n -- )
state
IF (compN) ELSE exN THEN ;
\ Here are the different types that we can put prefixes on or send
\ messages to:
TYPE{ notfnd locTyp flocTyp objTyp classTyp valTyp fvalTyp vecTyp
objptrTyp wordTyp regTyp lbTyp lbSelfTyp bktTyp }
\ notFnd - not previously defined
\ locTyp - a local or named parm
\ objTyp - an object
\ classTyp - a class
\ valTyp - a value
\ FvalTyp - a floating point value
\ vecTyp - a vector
\ wordTyp - an ordinary word
\ regTyp - a 680x0 register
\ lbTyp - ** or [] meaning late bind
\ lbSelfTyp - [self] meaning late bind to self
\ BktTyp - [ - Neon-compatible late bind
\ PRFTOKEN returns the type of a token for a prefix op.
\ First we need to make some handler codes available above the Nucleus.
: HDLR \ ( cfa -- ha )
2- w@x ;
' key hdlr constant VECTCODE
' base hdlr constant VALCODE
' ^base hdlr constant REGCODE
' hdlr hdlr constant WORDCODE
objPtr XX ' xx hdlr forget xx
constant OBJPTRCODE
: PRFTOKEN \ ( -- cfa type )
' dup ['] locParm = IF locTyp EXIT THEN
dup ['] FlocParm = IF FlocTyp EXIT THEN
dup hdlr
CASE
valCode OF valTyp ENDOF
FvalCode OF FvalTyp ENDOF
vectCode OF vecTyp ENDOF
regCode OF regTyp ENDOF
objPtrCode OF objPtrTyp ENDOF
?error 114
ENDCASE ;
forward ToObjPtr \ Stores to an objPtr. Defined in file Class.
: -> immediate
PrfToken \ All types are legal
objPtrTyp = if toObjPtr exit then
$ 60 ( opcode for Store ) ,exec ;
\ NOTE: opcode for store hard coded here!!!
: CvrtFcode \ ( code -- code' )
CASE
$ 21 OF $ 41 ENDOF \ +
$ 22 OF $ 48 ENDOF \ -
$ 28 OF $ 55 ENDOF \ Neg
?error 114
ENDCASE ;
: (+->) \ ( code -- cfa code' )
PrfToken ( code cfa type ) rot swap ( cfa code type )
SELECT{
locTyp IS{ }END
FlocTyp IS{ CvrtFcode }END
valTyp IS{ }END
FvalTyp IS{ CvrtFcode }END
regTyp IS{ }END
DEFAULT{ ?error 114
}SELECT ;
: (FOP)
PrfToken rot swap
SELECT{
locTyp IS{ }END
FlocTyp IS{ }END
FvalTyp IS{ }END
DEFAULT{ ?error 114
}SELECT ;
\ Note: the following opcodes have to agree with the definitions in
\ OD.asm. I could have defined them as constants but this would have
\ used up dictionary space for no great benefit.
: ++> $ 21 (+->) ,exec ; immediate
: +> postpone ++> ; immediate \ A synonym.
: --> $ 22 (+->) ,exec ; immediate
: AND> $ 23 (+->) ,exec ; immediate
: OR> $ 24 (+->) ,exec ; immediate
: XOR> $ 25 (+->) ,exec ; immediate
: NEG> $ 28 (+->) ,exec ; immediate
: NOT> $ 29 (+->) ,exec ; immediate
: *> $ 42 (fop) ,exec ; immediate
: /> $ 49 (fop) ,exec ; immediate
: ABS> $ 54 (fop) ,exec ; immediate
' Pfind -> Ufind
\ =========== Local sections ===========
: ?LOC local? not ?error 91 ;
: LOCAL
local? ?error 93 1 -> local? \ We change it to the normal -1
\ as soon as "{" is read.
forward ;
: :LOC immediate
?loc ?exec 304
here ' (patch) \ Like :F
#PL if PLentry then
false -> local? \ We do this here so any EXITs
\ tidy everything up properly
postpone ] ;
: ;LOC immediate
(;) 304 ?defn ; \ As local? is now false, everything else
\ gets tidied up by (;)
: EVALUATE { addr len \ cnt -- ?? }
save-input -> cnt
cnt for >r next \ Move input-stream specs to rtn stk
addr -> src-start len -> src-len 0 >in ! -1 -> source-id
echo? IF ." ***evaluating*** " addr len type cr THEN
interpret
cnt for r> next
cnt restore-input ?error 25 ;
: (COMPINL) \ ( cfa -- )
2+ count evaluate ;
' (compinl) -> compinline
: INLINE{ immediate
method? IF -4 allot THEN \ Wipe out method entry sequence
inlMk w, & } ,str
align-dp
method? IF Mentry THEN \ Recompile method entry sequence
postpone ] ;
<" Class